home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / PROGS / DBPASGEN.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  18KB  |  519 lines
  1. Program dbPasGen;
  2.  
  3. {$M 10000,0,10000}
  4.  
  5. uses PbMISC, PbDATA, PbOBJS, PbPARMS, PbXBASE;
  6.  
  7. {
  8. Description:  Program to generate PASCAL Type And OBJECT for dBase record
  9.  
  10. Author      : Howard Richoux
  11. Date        : 10/10/90
  12. Last revised: 11/10/90
  13.               11/25/93  hnr 2.00  support DBF OBJECT
  14.               12/13/93  hnr 2.05  keyed dbf object
  15.               12/17/93  hnr 2.10  OUT_object
  16.                1/10/94  hnr 2.15  make read & write boolean functions
  17.                1/12/94  hnr 2.20  memo READ support
  18.                1/16/94  hnr 2.25  handle 1 or 2 MEMO fields
  19.                1/29/94  hnr 2.26  dates are 8 bytes not 10, do reals better
  20.                2/9/94   hnr 2.28  added FINDREC (field, fieldval)
  21.                2/10/94  hnr 2.30  added DELETEREC (n)
  22.                2/18/94  HNR 2.32  NEW LIBRARIES
  23. Application : IBM PC and compatibles, done in Turbo Pascal 5.0
  24. Status      : Placed in the Public Domain by HNR Software 1/29/1994
  25. Published in: none
  26. }
  27.  
  28.  
  29.  
  30.  
  31. var dbfname : string[40];
  32. var dbf     : XBASE_DBF_object;
  33. var recname : string[7];
  34. var memoflag    : boolean;
  35.     memofield1   : string;
  36.     memofield1no : integer;
  37.     memofield2   : string;
  38.     memofield2no : integer;
  39.     memoconst    : string[5];
  40.  
  41. var L       : OUT_object_0;
  42.  
  43.  
  44. Procedure MakeUnit(dbroot : string);
  45. var i, width   : integer;
  46.     rtype      : char;
  47.     tmp, tpe   : string[40];
  48.      begin
  49.      L.out('{SECTION ..X'+dbroot+' }');
  50.      L.out(' ');
  51.      L.out('{ '+pProgID+' '+FormatDTime+'   Placed in the Public Domain by HNR Software 1/29/1994 }');
  52.      L.out(' ');
  53.      L.out('Unit x'+dbroot+';');
  54.      L.out(' ');
  55.      L.out('INTERFACE');
  56.      L.out(' ');
  57.      L.out('Uses PbMISC, PbDATA, PbOBJS, PbXBASE, PbDBOBJ, PbMEMO;');
  58.      L.out(' ');
  59.      end;
  60.  
  61.  
  62. Procedure MakeUnitEnd;
  63.      begin
  64.      L.out(' ');
  65.      L.out('{SECTION zzInitialization }');
  66.      L.out('      begin { initialization }');
  67.      L.out('      end.');
  68.      end;
  69.  
  70.  
  71. Procedure MakeObject(dbroot : string);
  72. var i, width   : integer;
  73.     rtype      : char;
  74.     tmp, tpe   : string[40];
  75.      begin
  76.      L.out('{SECTION .'+dbroot+'_DBF_object }');
  77.      L.out(' ');
  78.      L.out('const '+dbroot+'_DBF_recsize = '+
  79.                 integerstr(dbf.dbhead.rec_bytes,4)+';');
  80.      if memoflag then L.out('const memomaxlines = '+memoconst+';');
  81.      L.out(' ');
  82.      L.out('type  '+dbroot+'_DBF_object = OBJECT(keyed_DBF_object)');
  83.      L.out('         rec       : '+dbroot+'_record;');
  84.      L.out('         msg       : string[60];');
  85.      if memoflag then
  86.           begin
  87.           L.out('         memofile  : MEMO_object;');
  88.           L.out('         memo1     : STRA_object;');
  89.           if memofield2 <> '' then
  90.                L.out('         memo2     : STRA_object;');
  91.           L.out('         autoread  : boolean;');
  92.           L.out('         UpdateMemo: boolean;');
  93.           L.out('         Procedure  Init(fn : string; rcz,dm : integer;'+
  94.                                    'tg,ks : string; km : integer);');
  95.           L.out(' ');
  96.           end;
  97.      L.out('         Procedure  GetPas'+dbroot+';');
  98.      L.out('         Procedure  PutPas'+dbroot+';');
  99.      L.out('         Function   ReadRec  ( i : longint) : boolean;');
  100.      L.out('         Function   WriteRec ( i : longint) : boolean;');
  101.      L.out('         Function   DeleteRec ( i : longint) : boolean;');
  102.      L.out('         Function   FindRec  ( fnam,fval : string) : boolean;');
  103.      if memoflag then
  104.           begin
  105.           L.out('         Procedure  ReadMemos;');
  106.           end;
  107.      L.out('         end;');
  108.      L.out(' ');
  109.      L.out('{SECTION .zImplementation }');
  110.      L.out('IMPLEMENTATION');
  111.      L.out(' ');
  112.      end;
  113.  
  114.  
  115. Procedure MakeInitProc(dbroot : string);
  116. var i, width   : integer;
  117.     rtype      : char;
  118.     tmp,tmp2,tpe    : string[20];
  119.      begin
  120.      if not memoflag then exit;
  121.      L.out(' ');
  122.      L.out('Procedure  '+dbroot+'_DBF_object.Init(fn : string; rcz,dm : integer;'+
  123.                               'tg,ks : string; km : integer);');
  124.      L.out('var memofn : string;');
  125.      L.out('     begin');
  126.      L.out('     msg        := ''' + dbroot + ' init ok'';');
  127.      L.out('     autoread   := false;');
  128.      L.out('     updatememo := false;');
  129.      if memoflag then
  130.           begin
  131.           L.out('     memo1.init(memomaxlines);');
  132.           if memofield2 <> '' then
  133.                L.out('     memo2.init(memomaxlines);');
  134.           L.out('     memofn := fn; forceext(memofn,''dbt'');');
  135.           end;
  136.      L.out('     KEYED_DBF_object.init(fn,rcz,dm,tg,ks,km);');
  137.      L.out('     memofile.init(memofn,dm);');
  138.      L.out('     end;');
  139.      L.out(' ');
  140.      L.out(' ');
  141.      end;
  142.  
  143.  
  144.  
  145. Procedure MakeRecType(dbroot : string);
  146. var i, width, decp : integer;
  147.     rtype          : char;
  148.     tmp, tpe       : string;
  149.      begin
  150.      L.out('{SECTION .'+dbroot+'_record }');
  151.      L.out('type '+dbroot+'_record = record ');
  152.      for i := 1 to dbf.dbnumfields do
  153.          begin
  154.          tmp := leftstr(dbf.dbfldname(i),10);
  155.          rtype := dbf.dbfldrtype(i);
  156.          width := dbf.dbfldwidth(i);
  157.          decp  := dbf.dbflddecp(i);
  158.          case rtype of
  159.              'C' :tpe := 'string['+integerstr(width,3)+']';
  160.              'N' :begin
  161.                   if      decp  > 0 then  tpe := 'real'
  162.                   else if width < 5 then  tpe := 'integer'
  163.                   else if width < 10 then tpe := 'longint'
  164.                   else tpe := 'real';
  165.                   end;
  166.              'D' :tpe := 'string[8]      {date}';
  167.              'L' :tpe := 'boolean';
  168.              'M' :begin
  169.                   memoflag    := true;
  170.                   if memofield1 = '' then
  171.                        begin
  172.                        memofield1   := trimstr(tmp);
  173.                        memofield1no := i;
  174.                        tpe := 'longint        { memo1 }';
  175.                        end
  176.                   else begin
  177.                        memofield2   := trimstr(tmp);
  178.                        memofield2no := i;
  179.                        tpe := 'longint        { memo2 }';
  180.                        end;
  181.                   end;
  182.              else
  183.                   begin
  184.                   L.out('{ *** Unknown type ['+rtype+'] }');
  185.                   tpe := 'string[1]';
  186.                   end;
  187.              end;
  188.          removeblanks(tpe);
  189.          L.OUT('          _'+tmp+' : '+tpe+';');
  190.          end;
  191.      L.OUT('          end;');
  192.      L.out(' ');
  193.      end;
  194.  
  195.  
  196.  
  197. Procedure MakeGetPasProc(dbroot : string);
  198. var i, width, decp   : integer;
  199.     rtype            : char;
  200.     tmp,tmp2,tpe     : string[20];
  201.      begin
  202.      L.out('{SECTION '+dbroot+'_DBF_object }');
  203.      L.out(' ');
  204.      L.out('Procedure '+dbroot+'_DBF_object.GetPas'+dbroot+';');
  205.      L.OUT('     begin');
  206.      L.OUT('     fillchar(rec,sizeof(rec),0);');
  207.      L.OUT('     with rec do');
  208.      L.OUT('          begin');
  209.      for i := 1 to dbf.dbnumfields do
  210.          begin
  211.          tmp := leftstr(dbf.dbfldname(i),10);
  212.          rtype := dbf.dbfldrtype(i);
  213.          width := dbf.dbfldwidth(i);
  214.          decp  := dbf.dbflddecp(i);
  215.          case rtype of
  216.              'C' :tpe := 'dbstr';
  217.              'N' :begin
  218.                   if      decp  > 0 then  tpe := 'dbreal'
  219.                   else if width < 5 then  tpe := 'dbint'
  220.                   else if width < 10 then tpe := 'dblong'
  221.                   else tpe := 'dbreal';
  222.                   end;
  223.              'D' :tpe := 'dbstr';
  224.              'L' :tpe := 'dblogic';
  225.              'M' :tpe := 'dblong';
  226.              else tpe := 'dbbadtype';
  227.              end;
  228.          removeblanks(tpe);
  229.          tmp2 := tmp;
  230.          trim(tmp2);
  231.          L.OUT('          _'+tmp+' := dbf.'+tpe+'(dbf.dbfldno('''+
  232.                                   tmp2+'''));');
  233.          end;
  234.      L.OUT('          end;');
  235.      L.OUT('     end;');
  236.      L.out(' ');
  237.      L.out(' ');
  238.      end;
  239.  
  240.  
  241. Procedure MakePutPasProc(dbroot : string);
  242. var i, width, decp   : integer;
  243.     rtype            : char;
  244.     tmp,tmp2,tpe     : string[20];
  245.      begin
  246.      L.out(' ');
  247.      L.out('Procedure '+dbroot+'_DBF_object.PutPas'+dbroot+';');
  248.      L.OUT('     begin');
  249.      L.OUT('     dbf.dbcleardbbuf;');
  250.      L.OUT('     with rec do');
  251.      L.OUT('          begin');
  252.      for i := 1 to dbf.dbnumfields do
  253.          begin
  254.          tmp := leftstr(dbf.dbfldname(i),10);
  255.          rtype := dbf.dbfldrtype(i);
  256.          width := dbf.dbfldwidth(i);
  257.          decp  := dbf.dbflddecp(i);
  258.          case rtype of
  259.              'C' :tpe := 'dbputstr';
  260.              'N' :begin
  261.                   if      decp  > 0 then  tpe := 'dbputreal'
  262.                   else if width < 5 then  tpe := 'dbputint'
  263.                   else if width < 10 then tpe := 'dbputlong'
  264.                   else tpe := 'dbputreal';
  265.                   end;
  266.              'D' :tpe := 'dbputstr';
  267.              'L' :tpe := 'dbputlogic';
  268.              'M' :tpe := 'dbputlong';
  269.              else tpe := 'dbputbadtype';
  270.              end;
  271.          removeblanks(tpe);
  272.          tmp2 := tmp;
  273.          trim(tmp2);
  274.          trim(tmp);
  275.          L.OUT('          dbf.'+tpe+'(dbf.dbfldno('''+tmp2+'''), _'+tmp+');');
  276.          end;
  277.      L.OUT('          end;');
  278.      L.OUT('     end;');
  279.      L.out(' ');
  280.      L.out(' ');
  281.      end;
  282.  
  283.  
  284. Procedure MakeReadWriteProcs(dbroot : string);
  285. var i, width   : integer;
  286.     rtype      : char;
  287.     tmp,tmp2,tpe    : string[20];
  288.      begin
  289.      L.out(' ');
  290.      L.out('Function  '+dbroot+'_DBF_object.ReadRec( i : longint) : boolean;');
  291.      L.out('var memonum : longint;');
  292.      L.OUT('     begin');
  293.      L.out('     msg := '''+dbroot+' ReadRec ok.'';');
  294.      L.OUT('     ReadRec := true;');
  295.      L.OUT('     if not dbf.dbgoto(i) then ');
  296.      L.OUT('          begin');
  297.      L.OUT('          ReadRec := false;');
  298.      L.OUT('          fillchar(rec,sizeof(rec),0);');
  299.      L.out('          msg := ''' + dbroot + ' ReadRec failed. ('''+
  300.                              '+integerstr(err,4)+'')   ''+longintstr(i,6);');
  301.      L.OUT('          end');
  302.      L.OUT('     else begin');
  303.      L.OUT('          GetPas'+dbroot+';');
  304.      if memoflag then
  305.           L.OUT('          if autoread then ReadMemos;');
  306.      L.OUT('          end;');
  307.      L.OUT('     if dbf.dbdeleted then ');
  308.      L.out('          msg := ''' + dbroot + ' Current record is DELETED. ('''+
  309.                              '+integerstr(err,4)+'')   ''+longintstr(CurrRec,6);');
  310.      L.OUT('     end;');
  311.      L.out(' ');
  312.      L.out(' ');
  313.      L.out('Function  '+dbroot+'_DBF_object.WriteRec( i : longint) : boolean;');
  314.      L.out('var blocks   : integer;');
  315.      L.out('var memonum  : longint;');
  316.      L.out('var ok       : boolean;');
  317.      L.out('     begin');
  318.      L.out('     WriteRec := true;');
  319.      L.out('     msg := '''+dbroot+' WriteRec ok.'';');
  320.      if memoflag then
  321.           begin
  322.           L.out('     if updatememo then ');
  323.           L.out('          begin');
  324.           L.out('          memonum := dbf.dblong(dbf.dbfldno('''+memofield1+'''));');
  325.           L.out('          memofile.storeN(memo1,memonum,blocks);');
  326.           L.out('          rec._'+memofield1+' := memonum; { if memo needed to be moved }');
  327.           if memofield2 <> '' then
  328.                begin
  329.                L.out('          memonum := dbf.dblong(dbf.dbfldno('''+memofield2+'''));');
  330.                L.out('          memofile.storeN(memo2,memonum,blocks);');
  331.                L.out('          rec._'+memofield2+' := memonum; { if memo needed to be moved }');
  332.                end;
  333.           L.out('          end;');
  334.           end;
  335.      L.out('     PutPas'+dbroot+';');
  336.      L.out('     if i > numrecs then ok := dbf.dbappend');
  337.      L.out('     else begin');
  338.      L.out('          if dbf.dbposition(i) then ');
  339.      L.out('               ok := dbf.dbrewrite(i);');
  340.      L.out('          end;');
  341.      L.out('     if not ok then');
  342.      L.out('          begin');
  343.      L.out('          WriteRec := false;');
  344.      L.out('          msg := ''' + dbroot + ' WriteRec failed. ('''+
  345.                              '+integerstr(err,4)+'')   ''+longintstr(i,6);');
  346.      L.out('          end;');
  347.      L.out('     end;');
  348.      L.out(' ');
  349.      L.out(' ');
  350.      L.out('Function  '+dbroot+'_DBF_object.FindRec( fnam,fval : string) : boolean;');
  351.      L.out('var memonum : longint;');
  352.      L.OUT('     begin');
  353.      L.OUT('     FindRec := false;');
  354.      L.OUT('     if fetchwhere(fnam, ''='', fval) then ');
  355.      L.OUT('          begin');
  356.      L.OUT('          FindRec := true;');
  357.      L.OUT('          ReadRec(CurrRec);');
  358.      L.OUT('          end');
  359.      L.OUT('     else begin');
  360.      L.OUT('          TOP;');
  361.      L.OUT('          dbf.dbcleardbbuf;');
  362.      L.OUT('          GetPas'+dbroot+';');
  363.      L.out('          msg := ''' + dbroot + ' FindRec failed. ('''+
  364.                         '+integerstr(err,4)+'')   [''+fnam+'',''+fval+'']'';');
  365.      L.OUT('          end;');
  366.      L.OUT('     end;');
  367.      L.out(' ');
  368.      L.out(' ');
  369.      L.out('Function  '+dbroot+'_DBF_object.DeleteRec( i : longint) : boolean;');
  370.      L.out('var ok           : boolean;');
  371.      L.out('     begin');
  372.      L.out('     DeleteRec := true;');
  373.      L.out('     msg := '''+dbroot+' DeleteRec ok.'';');
  374.      L.out('     if i <> CurrRec then ');
  375.      L.out('          begin');
  376.      L.out('          msg := ''' + dbroot + ' DeleteRec failed. Record not current. curr='''+
  377.                              '+longintstr(CurrRec,6)+'' <> i=''+longintstr(i,6);');
  378.      L.out('          DeleteRec := false;');
  379.      L.out('          end');
  380.      L.out('     else begin');
  381.      L.out('          ok := dbf.dbdelete(i);');
  382.      L.out('          if not ok then ');
  383.      L.out('               begin');
  384.      L.out('               DeleteRec := false;');
  385.      L.out('               msg := ''' + dbroot + ' DeleteRec failed. ('''+
  386.                              '+integerstr(err,4)+'')   ''+longintstr(i,6);');
  387.      L.out('               end;');
  388.      L.out('          end;');
  389.      L.out('     end;');
  390.      L.out(' ');
  391.      L.out(' ');
  392.      L.out(' ');
  393.      end;
  394.  
  395.  
  396. Procedure MakeMEMOProcs(dbroot : string);
  397. var i, width   : integer;
  398.     rtype      : char;
  399.     tmp,tmp2,tpe    : string[20];
  400.      begin
  401.      if not memoflag then exit;
  402.      L.out(' ');
  403.      L.out('Procedure '+dbroot+'_DBF_object.ReadMemos;');
  404.      L.out('var error,blocks : integer;');
  405.      L.out('var memonum      : longint;');
  406.      L.out('     begin');
  407.      L.out('     error := 0;');
  408.      L.out('     memo1.clear;');
  409.      L.out('     memonum := dbf.dblong(dbf.dbfldno('''+memofield1+'''));');
  410.      L.out('     if memonum > 0 then memofile.fetchN(memonum,memo1,blocks);');
  411.      if memofield2 <> '' then
  412.           begin
  413.           L.out('     memo2.clear;');
  414.           L.out('     memonum := dbf.dblong(dbf.dbfldno('''+memofield2+'''));');
  415.           L.out('     if memonum > 0 then memofile.fetchN(memonum,memo2,blocks);');
  416.           end;
  417.      L.out('     end;');
  418.      L.out(' ');
  419.      L.out(' ');
  420.      end;
  421.  
  422.  
  423. Function MakeRoot(path : string) : string;
  424. var s : string;
  425.     i : integer;
  426.      begin
  427.      s := path;
  428.      i := pos('\',s);
  429.      while i > 0 do
  430.           begin
  431.           delete(s,1,i);
  432.           i := pos('\',s);
  433.           end;
  434.      i := pos('.',s);
  435.      if i > 1 then s := leftstr(s,i-1);
  436.      Makeroot := s;
  437.      end;
  438.  
  439.  
  440. Procedure MakePas(dbroot : string);
  441. var outfname : string[40];
  442.      begin
  443.      getdir(0,outfname);
  444.      outfname := addbackslash(outfname) + 'x' + dbroot;
  445.      forceext(outfname,'pas');
  446.      writeln('writing to ',outfname);
  447.      L.LISTinit(outfname,OUT_typREWRITE);
  448.      L.LISTopen;
  449.  
  450.      MakeUnit(dbroot);
  451.      MakeRecType(dbroot);
  452.      MakeObject(dbroot);
  453.      MakeInitProc(dbroot);
  454.      MakeGetPasProc(dbroot);
  455.      MakePutPasProc(dbroot);
  456.      MakeReadWriteProcs(dbroot);
  457.      MakeMEMOProcs(dbroot);
  458.      MakeUnitEnd;
  459.  
  460.      L.done;
  461.      end;
  462.  
  463.  
  464. Procedure DodbPasGen(dbfname : string);
  465. var fn : string[40];
  466.     i  : integer;
  467.     dbroot : string[8];
  468.      begin
  469.      fn := dbfname;
  470.      ForceExt(fn,'dbf');
  471.      writeln('fn ',fn);
  472.  
  473.  
  474.      if recname = '' then dbroot := UpCaseStr(MakeRoot(fn))
  475.      else dbroot := UpCaseStr(recname);
  476.      writeln('record name= ',dbroot);
  477.      dbf.init(fn,dbREADONLY);
  478.      if dbf.err = 0 then
  479.           begin
  480.           dbf.dbShowstruc;
  481.           MakePas(dbroot);
  482.           dbf.dbclose;
  483.           if (dbf.err <> 0) then writeln('Error closing dBase file');
  484.           end
  485.      else writeln('Unable to open dBase file: ',fn);
  486.      end;
  487.  
  488.  
  489. Procedure dbPasGenInit;
  490.      begin
  491.      memoflag     := false;
  492.      memofield1   := '';
  493.      memofield1no := 0;
  494.      memofield2   := '';
  495.      memofield2no := 0;
  496.      recname := '';
  497.      dbfname := '';
  498.      AddParm(1,'MEMOCONST','500');
  499.  
  500.      StandardpVarsInit;
  501.  
  502.      memoconst := GetParmStr('MEMOCONST');
  503.      if paramcount > 0 then dbfname := paramstr(1);
  504.      if paramcount > 1 then recname := paramstr(2);
  505.      end;
  506.  
  507.  
  508.      begin
  509.      pProgID := 'dbPasGen 2.32';
  510.      writeln(pProgID, ' - Utility support for DBF object - HNR 11/93');
  511.      dbPasGenInit;
  512.      if dbfname <> '' then
  513.           begin
  514.           DodbPasGen(dbfname);
  515.           end
  516.      else writeln('dBase file name not passed as run parameter.');
  517.      writeln('');
  518.      end.
  519.